home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
QRZ! Ham Radio 8
/
QRZ Ham Radio Callsign Database - Volume 8.iso
/
mac
/
files
/
ant_nec
/
nec81tar.z
/
nec81tar
/
datagn2.f
< prev
next >
Wrap
Text File
|
1991-05-13
|
24KB
|
879 lines
C $TITLE: 'DATAGN2'
C $NOFLOATCALLS
C
C
SUBROUTINE PATCH (NX,NY,X1,Y1,Z1,X2,Y2,Z2,X3,Y3,Z3,X4,Y4,Z4,
1 X,Y,Z,BI,SALP,T1X,T1Y,T1Z,T2X,T2Y,T2Z,LD)
C PATCH GENERATES AND MODIFIES PATCH GEOMETRY DATA
INTEGER*4 N1,N2,N,NP,M1,M2,M,MP,IPSYM
REAL*8 XA,XST,SALPN,X1,Y1,Z1,X2,Y2,Z2,XNV,YNV,ZNV,S1X,S1Y,S1Z,
1 S2X,S2Y,S2Z,XN2,YN2,ZN2,XS,YS,ZS,XT,YT,ZT
COMMON/DATAD/N1,N2,N,NP,M1,M2,M,MP,IPSYM,WLAM
DIMENSION X(LD),Y(LD),Z(LD),BI(LD),SALP(LD)
DIMENSION T1X(LD),T1Y(LD),T1Z(LD),T2X(LD),T2Y(LD),T2Z(LD)
C NEW PATCHES. FOR NX=0, NY=1,2,3,4 PATCH IS (RESPECTIVELY)
C ARBITRARY, RECTAGULAR, TRIANGULAR, OR QUADRILATERAL.
C FOR NX AND NY .GT. 0 A RECTANGULAR SURFACE IS PRODUCED WITH
C NX BY NY RECTANGULAR PATCHES.
M=M+1
MI=LD+1-M
NTP=NY
IF (NX.GT.0) NTP=2
IF (NTP.GT.1) GO TO 2
X(MI)=X1
Y(MI)=Y1
Z(MI)=Z1
BI(MI)=Z2
ZNV=DCOS(X2)
XNV=ZNV*DCOS(Y2)
YNV=ZNV*DSIN(Y2)
ZNV=DSIN(X2)
XA=DSQRT(XNV*XNV+YNV*YNV)
IF (XA.LT.1.E-6) GO TO 1
T1X(MI)=-YNV/XA
T1Y(MI)=XNV/XA
T1Z(MI)=0.
GO TO 6
1 T1X(MI)=1.
T1Y(MI)=0.
T1Z(MI)=0.
GO TO 6
2 S1X=X2-X1
S1Y=Y2-Y1
S1Z=Z2-Z1
S2X=X3-X2
S2Y=Y3-Y2
S2Z=Z3-Z2
IF (NX.EQ.0) GO TO 3
S1X=S1X/NX
S1Y=S1Y/NX
S1Z=S1Z/NX
S2X=S2X/NY
S2Y=S2Y/NY
S2Z=S2Z/NY
3 XNV=S1Y*S2Z-S1Z*S2Y
YNV=S1Z*S2X-S1X*S2Z
ZNV=S1X*S2Y-S1Y*S2X
XA=DSQRT(XNV*XNV+YNV*YNV+ZNV*ZNV)
XNV=XNV/XA
YNV=YNV/XA
ZNV=ZNV/XA
XST=DSQRT(S1X*S1X+S1Y*S1Y+S1Z*S1Z)
T1X(MI)=S1X/XST
T1Y(MI)=S1Y/XST
T1Z(MI)=S1Z/XST
IF (NTP.GT.2) GO TO 4
X(MI)=X1+.5*(S1X+S2X)
Y(MI)=Y1+.5*(S1Y+S2Y)
Z(MI)=Z1+.5*(S1Z+S2Z)
BI(MI)=XA
GO TO 6
4 IF (NTP.EQ.4) GO TO 5
X(MI)=(X1+X2+X3)/3.
Y(MI)=(Y1+Y2+Y3)/3.
Z(MI)=(Z1+Z2+Z3)/3.
BI(MI)=.5*XA
GO TO 6
5 S1X=X3-X1
S1Y=Y3-Y1
S1Z=Z3-Z1
S2X=X4-X1
S2Y=Y4-Y1
S2Z=Z4-Z1
XN2=S1Y*S2Z-S1Z*S2Y
YN2=S1Z*S2X-S1X*S2Z
ZN2=S1X*S2Y-S1Y*S2X
XST=DSQRT(XN2*XN2+YN2*YN2+ZN2*ZN2)
SALPN=1./(3.*(XA+XST))
X(MI)=(XA*(X1+X2+X3)+XST*(X1+X3+X4))*SALPN
Y(MI)=(XA*(Y1+Y2+Y3)+XST*(Y1+Y3+Y4))*SALPN
Z(MI)=(XA*(Z1+Z2+Z3)+XST*(Z1+Z3+Z4))*SALPN
BI(MI)=.5*(XA+XST)
S1X=(XNV*XN2+YNV*YN2+ZNV*ZN2)/XST
IF (S1X.GT.0.9998) GO TO 6
WRITE(*,14)
STOP
6 T2X(MI)=YNV*T1Z(MI)-ZNV*T1Y(MI)
T2Y(MI)=ZNV*T1X(MI)-XNV*T1Z(MI)
T2Z(MI)=XNV*T1Y(MI)-YNV*T1X(MI)
SALP(MI)=1.
IF (NX.EQ.0) GO TO 8
M=M+NX*NY-1
XN2=X(MI)-S1X-S2X
YN2=Y(MI)-S1Y-S2Y
ZN2=Z(MI)-S1Z-S2Z
XS=T1X(MI)
YS=T1Y(MI)
ZS=T1Z(MI)
XT=T2X(MI)
YT=T2Y(MI)
ZT=T2Z(MI)
MI=MI+1
DO 7 IY=1,NY
XN2=XN2+S2X
YN2=YN2+S2Y
ZN2=ZN2+S2Z
DO 7 IX=1,NX
XST=IX
MI=MI-1
X(MI)=XN2+XST*S1X
Y(MI)=YN2+XST*S1Y
Z(MI)=ZN2+XST*S1Z
BI(MI)=XA
SALP(MI)=1.
T1X(MI)=XS
T1Y(MI)=YS
T1Z(MI)=ZS
T2X(MI)=XT
T2Y(MI)=YT
7 T2Z(MI)=ZT
8 IPSYM=0
NP=N
MP=M
RETURN
C
14 FORMAT (62H ERROR -- CORNERS OF QUADRILATERAL PATCH DO NOT LIE IN
1A PLANE)
END
C
C
C DIVIDE PATCH FOR WIRE CONNECTION
C
C
SUBROUTINE SUBPH(NX,NY,X,Y,Z,BI,SALP,T1X,T1Y,T1Z,T2X,T2Y,T2Z,LD)
INTEGER*4 N1,N2,N,NP,M1,M2,M,MP,IPSYM
COMMON/DATAD/N1,N2,N,NP,M1,M2,M,MP,IPSYM,WLAM
DIMENSION X(LD),Y(LD),Z(LD),BI(LD),SALP(LD)
DIMENSION T1X(LD),T1Y(LD),T1Z(LD),T2X(LD),T2Y(LD),T2Z(LD)
IF (NY.GT.0) GO TO 10
IF (NX.EQ.M) GO TO 10
NXP=NX+1
IXX=LD-M
C**
DO 9 IY=NXP,M
IXX=IXX+1
NYP=IXX-3
X(NYP)=X(IXX)
Y(NYP)=Y(IXX)
Z(NYP)=Z(IXX)
BI(NYP)=BI(IXX)
SALP(NYP)=SALP(IXX)
T1X(NYP)=T1X(IXX)
T1Y(NYP)=T1Y(IXX)
T1Z(NYP)=T1Z(IXX)
T2X(NYP)=T2X(IXX)
T2Y(NYP)=T2Y(IXX)
9 T2Z(NYP)=T2Z(IXX)
C**
10 MI=LD+1-NX
XS=X(MI)
YS=Y(MI)
ZS=Z(MI)
XA=BI(MI)*.25
C XST=DSQRT(XA)*.5
XST=SQRT(XA)*.5
S1X=T1X(MI)
S1Y=T1Y(MI)
S1Z=T1Z(MI)
S2X=T2X(MI)
S2Y=T2Y(MI)
S2Z=T2Z(MI)
SALN=SALP(MI)
XT=XST
YT=XST
IF (NY.GT.0) GO TO 11
MIA=MI
GO TO 12
11 M=M+1
MP=MP+1
MIA=LD+1-M
12 CONTINUE
DO 13 IXX=1,4
X(MIA)=XS+XT*S1X+YT*S2X
Y(MIA)=YS+XT*S1Y+YT*S2Y
Z(MIA)=ZS+XT*S1Z+YT*S2Z
BI(MIA)=XA
T1X(MIA)=S1X
T1Y(MIA)=S1Y
T1Z(MIA)=S1Z
T2X(MIA)=S2X
T2Y(MIA)=S2Y
T2Z(MIA)=S2Z
SALP(MIA)=SALN
IF (IXX.EQ.2) YT=-YT
IF (IXX.EQ.1.OR.IXX.EQ.3) XT=-XT
MIA=MIA-1
13 CONTINUE
C**
M=M+3
IF (NX.LE.MP) MP=MP+3
IF (NY.GT.0) Z(MI)=10000.
RETURN
END
C
C
C
SUBROUTINE ARC(ITG,NS,RADA,ANG1,ANG2,RAD,X,Y,Z,BI,ITAG,X2,Y2,
1 Z2,LD)
C
C ARC GENERATES SEGMENT GEOMETRY DATA FOR AN ARC OF NS SEGMENTS
C
INTEGER*4 ITAG,N1,N2,N,NP,M1,M2,M,MP,IPSYM
REAL*8 ANG,RADA,ANG1,ANG2,RAD,TA
COMMON/DATAD/N1,N2,N,NP,M1,M2,M,MP,IPSYM,WLAM
DIMENSION X(LD),Y(LD),Z(LD),BI(LD)
DIMENSION X2(LD),Y2(LD),Z2(LD),ITAG(LD)
DATA TA/.01745329252D0/
IST=N+1
N=N+NS
NP=N
MP=M
IPSYM=0
IF (NS.LT.1) RETURN
IF (ABS(ANG2-ANG1).LT.360.00001) GO TO 1
WRITE(*,3)
STOP
1 ANG=ANG1*TA
DANG=(ANG2-ANG1)*TA/NS
XS1=RADA*DCOS(ANG)
ZS1=RADA*DSIN(ANG)
DO 2 I=IST,N
ANG=ANG+DANG
XS2=RADA*DCOS(ANG)
ZS2=RADA*DSIN(ANG)
X(I)=XS1
Y(I)=0.
Z(I)=ZS1
X2(I)=XS2
Y2(I)=0.
Z2(I)=ZS2
XS1=XS2
ZS1=ZS2
BI(I)=RAD
2 ITAG(I)=ITG
RETURN
C
3 FORMAT (40H ERROR -- ARC ANGLE EXCEEDS 360. DEGREES)
END
C
C
C
SUBROUTINE CONECT(X,Y,Z,BI,SALP,T1X,T1Y,T1Z,T2X,T2Y,T2Z,
1 ICON1,ICON2,ICONX,IGND,IW,LD)
C
C CONNECT SETS UP SEGMENT CONNECTION DATA IN ARRAYS ICON1 AND ICON2
C BY SEARCHING FOR SEGMENT ENDS THAT ARE IN CONTACT.
C
INTEGER*4 ICON1,ICON2,ICONX,N1,N2,N,NP,M1,M2,M,MP,IPSYM
REAL*8 AX,BX,CX
COMMON/DATAD/N1,N2,N,NP,M1,M2,M,MP,IPSYM,WLAM
COMMON/SEGJ/AX(30),BX(30),CX(30),JCO(30),JSNO,ISCON(50),NSCON,
1 IPCON(10),NPCON
DIMENSION ICON1(LD),ICON2(LD),ICONX(LD)
DIMENSION X(LD),Y(LD),Z(LD),BI(LD),SALP(LD)
DIMENSION T1X(LD),T1Y(LD),T1Z(LD),T2X(LD),T2Y(LD),T2Z(LD)
DATA JMAX/30/,SMIN/1.E-3/,NSMAX/50/,NPMAX/10/
C**
NSCON=0
NPCON=0
IF (IGND.EQ.0) GO TO 3
WRITE(IW,54)
IF (IGND.GT.0) WRITE(IW,55)
IF (IPSYM.NE.2) GO TO 1
NP=2*NP
MP=2*MP
1 IF (IABS(IPSYM).LE.2) GO TO 2
NP=N
MP=M
2 IF (NP.GT.N) STOP
IF (NP.EQ.N.AND.MP.EQ.M) IPSYM=0
3 IF (N.EQ.0) GO TO 26
DO 15 I=1,N
ICONX(I)=0
XI1=X(I)
YI1=Y(I)
ZI1=Z(I)
XI2=T1X(I)
YI2=T1Y(I)
ZI2=T1Z(I)
C SLEN=DSQRT((XI2-XI1)**2+(YI2-YI1)**2+(ZI2-ZI1)**2)*SMIN
SLEN=SQRT((XI2-XI1)**2+(YI2-YI1)**2+(ZI2-ZI1)**2)*SMIN
C
C DETERMINE CONNECTION DATA FOR END 1 OF SEGMENT.
C
IF (IGND.LT.1) GO TO 5
IF (ZI1.GT.-SLEN) GO TO 4
WRITE(*,56) I
STOP
4 IF (ZI1.GT.SLEN) GO TO 5
ICON1(I)=I
Z(I)=0.
GO TO 9
5 IC=I
DO 7 J=2,N
IC=IC+1
IF (IC.GT.N) IC=1
SEP=ABS(XI1-X(IC))+ABS(YI1-Y(IC))+ABS(ZI1-Z(IC))
IF (SEP.GT.SLEN) GO TO 6
ICON1(I)=-IC
GO TO 8
6 SEP=ABS(XI1-T1X(IC))+ABS(YI1-T1Y(IC))+ABS(ZI1-T1Z(IC))
IF (SEP.GT.SLEN) GO TO 7
ICON1(I)=IC
GO TO 8
7 CONTINUE
IF (I.LT.N2.AND.ICON1(I).GT.10000) GO TO 8
ICON1(I)=0
C
C DETERMINE CONNECTION DATA FOR END 2 OF SEGMENT.
C
8 IF (IGND.LT.1) GO TO 12
9 IF (ZI2.GT.-SLEN) GO TO 10
WRITE(*,56) I
STOP
10 IF (ZI2.GT.SLEN) GO TO 12
IF (ICON1(I).NE.I) GO TO 11
WRITE(*,57) I
STOP
11 ICON2(I)=I
T1Z(I)=0.
GO TO 15
12 IC=I
DO 14 J=2,N
IC=IC+1
IF (IC.GT.N) IC=1
SEP=ABS(XI2-X(IC))+ABS(YI2-Y(IC))+ABS(ZI2-Z(IC))
IF (SEP.GT.SLEN) GO TO 13
ICON2(I)=IC
GO TO 15
13 SEP=ABS(XI2-T1X(IC))+ABS(YI2-T1Y(IC))+ABS(ZI2-T1Z(IC))
IF (SEP.GT.SLEN) GO TO 14
ICON2(I)=-IC
GO TO 15
14 CONTINUE
IF (I.LT.N2.AND.ICON2(I).GT.10000) GO TO 15
ICON2(I)=0
15 CONTINUE
IF (M.EQ.0) GO TO 26
C FIND WIRE-SURFACE CONNECTIONS FOR NEW PATCHES
IX=LD+1-M1
I=M2
16 IF (I.GT.M) GO TO 20
IX=IX-1
XS=X(IX)
YS=Y(IX)
ZS=Z(IX)
DO 18 ISEG=1,N
XI1=X(ISEG)
YI1=Y(ISEG)
ZI1=Z(ISEG)
XI2=T1X(ISEG)
YI2=T1Y(ISEG)
ZI2=T1Z(ISEG)
SLEN=(ABS(XI2-XI1)+ABS(YI2-YI1)+ABS(ZI2-ZI1))*SMIN
C FOR FIRST END OF SEGMENT
SEP=ABS(XI1-XS)+ABS(YI1-YS)+ABS(ZI1-ZS)
IF (SEP.GT.SLEN) GO TO 17
C CONNECTION - DIVIDE PATCH INTO 4 PATCHES AT PRESENT ARRAY LOC.
ICON1(ISEG)=10000+I
IC=0
CALL SUBPH(I,IC,X,Y,Z,BI,SALP,T1X,T1Y,T1Z,T2X,T2Y,T2Z,LD)
GO TO 19
17 SEP=ABS(XI2-XS)+ABS(YI2-YS)+ABS(ZI2-ZS)
IF (SEP.GT.SLEN) GO TO 18
ICON2(ISEG)=10000+I
IC=0
CALL SUBPH(I,IC,X,Y,Z,BI,SALP,T1X,T1Y,T1Z,T2X,T2Y,T2Z,LD)
GO TO 19
18 CONTINUE
19 I=I+1
GO TO 16
C REPEAT SEARCH FOR NEW SEGMENTS CONNECTED TO NGF PATCHES.
20 IF (M1.EQ.0.OR.N2.GT.N) GO TO 26
IX=LD+1
I=1
21 IF (I.GT.M1) GO TO 25
IX=IX-1
XS=X(IX)
YS=Y(IX)
ZS=Z(IX)
DO 23 ISEG=N2,N
XI1=X(ISEG)
YI1=Y(ISEG)
ZI1=Z(ISEG)
XI2=T1X(ISEG)
YI2=T1Y(ISEG)
ZI2=T1Z(ISEG)
SLEN=(ABS(XI2-XI1)+ABS(YI2-YI1)+ABS(ZI2-ZI1))*SMIN
SEP=ABS(XI1-XS)+ABS(YI1-YS)+ABS(ZI1-ZS)
IF (SEP.GT.SLEN) GO TO 22
ICON1(ISEG)=10001+M
IC=1
NPCON=NPCON+1
IPCON(NPCON)=I
CALL SUBPH(I,IC,X,Y,Z,BI,SALP,T1X,T1Y,T1Z,T2X,T2Y,T2Z,LD)
GO TO 24
22 SEP=ABS(XI2-XS)+ABS(YI2-YS)+ABS(ZI2-ZS)
IF (SEP.GT.SLEN) GO TO 23
ICON2(ISEG)=10001+M
IC=1
NPCON=NPCON+1
IPCON(NPCON)=I
CALL SUBPH(I,IC,X,Y,Z,BI,SALP,T1X,T1Y,T1Z,T2X,T2Y,T2Z,LD)
GO TO 24
23 CONTINUE
24 I=I+1
GO TO 21
25 IF (NPCON.LE.NPMAX) GO TO 26
WRITE(*,62) NPMAX
STOP
26 WRITE(IW,58) N,NP,IPSYM
IF (M.GT.0) WRITE(IW,61) M,MP
ISEG=(N+M)/(NP+MP)
IF (ISEG.EQ.1) GO TO 30
IF (IPSYM) 28,27,29
27 STOP
28 WRITE(IW,59) ISEG
GO TO 30
29 IC=ISEG/2
IF (ISEG.EQ.8) IC=3
WRITE(IW,60) IC
30 IF (N.EQ.0) GO TO 48
WRITE(IW,50)
ISEG=0
C ADJUST CONNECTED SEG. ENDS TO EXACTLY COINCIDE. PRINT JUNCTIONS
C OF 3 OR MORE SEG. ALSO FIND OLD SEG. CONNECTING TO NEW SEG.
DO 44 J=1,N
IEND=-1
JEND=-1
IX=ICON1(J)
IC=1
JCO(1)=-J
XA=X(J)
YA=Y(J)
ZA=Z(J)
31 IF (IX.EQ.0) GO TO 43
IF (IX.EQ.J) GO TO 43
IF (IX.GT.10000) GO TO 43
NSFLG=0
32 IF (IX) 33,49,34
33 IX=-IX
GO TO 35
34 JEND=-JEND
35 IF (IX.EQ.J) GO TO 37
IF (IX.LT.J) GO TO 43
IC=IC+1
IF (IC.GT.JMAX) GO TO 49
JCO(IC)=IX*JEND
IF (IX.GT.N1) NSFLG=1
IF (JEND.EQ.1) GO TO 36
XA=XA+X(IX)
YA=YA+Y(IX)
ZA=ZA+Z(IX)
IX=ICON1(IX)
GO TO 32
36 XA=XA+T1X(IX)
YA=YA+T1Y(IX)
ZA=ZA+T1Z(IX)
IX=ICON2(IX)
GO TO 32
37 SEP=IC
XA=XA/SEP
YA=YA/SEP
ZA=ZA/SEP
DO 39 I=1,IC
IX=JCO(I)
IF (IX.GT.0) GO TO 38
IX=-IX
X(IX)=XA
Y(IX)=YA
Z(IX)=ZA
GO TO 39
38 T1X(IX)=XA
T1Y(IX)=YA
T1Z(IX)=ZA
39 CONTINUE
IF (N1.EQ.0) GO TO 42
IF (NSFLG.EQ.0) GO TO 42
DO 41 I=1,IC
IX=IABS(JCO(I))
IF (IX.GT.N1) GO TO 41
IF (ICONX(IX).NE.0) GO TO 41
NSCON=NSCON+1
IF (NSCON.LE.NSMAX) GO TO 40
WRITE(*,62) NSMAX
STOP
40 ISCON(NSCON)=IX
ICONX(IX)=NSCON
41 CONTINUE
42 IF (IC.LT.3) GO TO 43
ISEG=ISEG+1
WRITE(IW,51) ISEG,(JCO(I),I=1,IC)
43 IF (IEND.EQ.1) GO TO 44
IEND=1
JEND=1
IX=ICON2(J)
IC=1
JCO(1)=J
XA=T1X(J)
YA=T1Y(J)
ZA=T1Z(J)
GO TO 31
44 CONTINUE
IF (ISEG.EQ.0) WRITE(IW,52)
IF (N1.EQ.0.OR.M1.EQ.M) GO TO 48
C FIND OLD SEGMENTS THAT CONNECT TO NEW PATCHES
DO 47 J=1,N1
IX=ICON1(J)
IF (IX.LT.10000) GO TO 45
IX=IX-10000
IF (IX.GT.M1) GO TO 46
45 IX=ICON2(J)
IF (IX.LT.10000) GO TO 47
IX=IX-10000
IF (IX.LT.M2) GO TO 47
46 IF (ICONX(J).NE.0) GO TO 47
NSCON=NSCON+1
ISCON(NSCON)=J
ICONX(J)=NSCON
47 CONTINUE
48 CONTINUE
C**
C WRITE(*,*) ' CONECT RETURN'
C**
RETURN
49 WRITE(*,53) IX
STOP
C
50 FORMAT (//,9X,27H- MULTIPLE WIRE JUNCTIONS -,/,1X,8HJUNCTION,4X,36
1HSEGMENTS (- FOR END 1, + FOR END 2))
51 FORMAT (1X,I5,5X,20I5,/,(11X,20I5))
52 FORMAT (2X,4HNONE)
53 FORMAT (47H CONNECT - SEGMENT CONNECTION ERROR FOR SEGMENT,I5)
54 FORMAT (/,3X,23HGROUND PLANE SPECIFIED.)
55 FORMAT (/,3X,46HWHERE WIRE ENDS TOUCH GROUND, CURRENT WILL BE ,38H
1INTERPOLATED TO IMAGE IN GROUND PLANE.,/)
56 FORMAT (30H GEOMETRY DATA ERROR-- SEGMENT,I5,21H EXTENDS BELOW GRO
1UND)
57 FORMAT (29H GEOMETRY DATA ERROR--SEGMENT,I5,16H LIES IN GROUND ,6H
1PLANE.)
58 FORMAT (/,3X,20HTOTAL SEGMENTS USED=,I5,5X,12HNO. SEG. IN ,17HA SY
1MMETRIC CELL=,I5,5X,14HSYMMETRY FLAG=,I3)
59 FORMAT (14H STRUCTURE HAS,I4,25H FOLD ROTATIONAL SYMMETRY,/)
60 FORMAT (14H STRUCTURE HAS,I2,19H PLANES OF SYMMETRY,/)
61 FORMAT (3X,19HTOTAL PATCHES USED=,I5,6X,32HNO. PATCHES IN A SYMMET
1RIC CELL=,I5)
62 FORMAT(54H ERROR - NO. NEW SEGMENTS CONNECTED TO N.G.F. SEGMENTS,
128H OR PATCHES EXCEEDS LIMIT OF,I5)
END
C***
C*** WILL REPLACE SUBROUTINE HELIX WITH ONE FROM NEC3 RWA 02 APR 89
C***
C*** SUBROUTINE HELIX(IW,ITG,NS,RAD1,RAD2,HT,TURNS,RAD,X,Y,Z,
C*** 1 BI,ITAG,X2,Y2,Z2,LD)
C
C SUBROUTINE HELIX GENERATES SEGMENT GEOMETRY DATA FOR A HELIX/SPIRAL
C
C RAD1 IS THE STRUCTURE RADIUS AT THE START
C RAD2 IS THE STRUCTURE RADIUS AT THE END
C HT IS THE STRUCTURE HEIGHT IN THE Z DIRECTION
C TURNS IS THE TOTAL NUMBER OF WINDINGS
C
C ASSUMING THAT RAD1.LE.RAD2 AND HT.NE.0, SAVE
C IF RAD1.EQ.RAD2 THE STRUCTURE WILL BE A HELIX
C IF RAD1.LT.RAD2 THE STRUCTURE WILL BE A SPIRAL
C IF TURNS.GT.0 THE STRUCTURE WILL BE RIGHT-HANDED
C IF TURNS.LT.0 THE STRUCTURE WILL BE LEFT-HANDED
C
C*** INTEGER*4 ITAG,N1,N2,N,NP,M1,M2,M,MP,IPSYM
C*** REAL*8 PI,HT,RAD1,RAD2,RAD,TWOPI
C*** COMMON/DATAD/N1,N2,N,NP,M1,M2,M,MP,IPSYM,WLAM
C*** DIMENSION X2(LD),Y2(LD),Z2(LD),ITAG(LD)
C*** DIMENSION X(LD),Y(LD),Z(LD),BI(LD)
C*** DATA PI/3.141592654D0/
C*** IST = N+1
C*** N = N+NS
C*** NP = N
C*** MP = M
C*** IPSYM = 0
C*** IF(NS.LT.1) RETURN
C*** TWOPI = 2.0*PI
C*** DO 100 I=1,NS
C*** PHI1 = FLOAT(I-1)/FLOAT(NS)
C*** PHI2 = FLOAT(I)/FLOAT(NS)
C*** R1 = (1.0-PHI1)*RAD1 + PHI1*RAD2
C*** R2 = (1.0-PHI2)*RAD1 + PHI2*RAD2
C*** ANGLE1 = TWOPI*TURNS*PHI1
C*** ANGLE2 = TWOPI*TURNS*PHI2
C*** X(IST) = R1*COS(ANGLE1)
C*** Y(IST) = R1*SIN(ANGLE1)
C*** Z(IST) = PHI1*HT
C*** X2(IST) = R2*COS(ANGLE2)
C*** Y2(IST) = R2*SIN(ANGLE2)
C*** Z2(IST) = PHI2*HT
C*** BI(IST) = RAD
C*** ITAG(IST) = ITG
C*** IST = IST+1
C***100 CONTINUE
C*** IF(RAD1.EQ.RAD2) THEN
C*** PITCH = ABS(HT/TURNS)
C*** WRITE(IW,110) PITCH
CCC110 FORMAT(3X,'THE PITCH OF THE HELIX IS ',F10.4)
C*** ELSE
C*** XS = ABS(HT)
C*** YS = ABS(RAD2-RAD1)
C*** ANGLE = ATAN2(YS,XS)*(180.0/PI)
C*** WRITE(IW,120) ANGLE
CCC120 FORMAT(3X,'THE HALF APEX ANGLE OF THE SPIRAL IS ',F7.3)
C*** ENDIF
C*** RETURN
C*** END
C
SUBROUTINE HELIX(IW,S,HL,A1,B1,A2,B2,RAD,NS,ITG,X,Y,Z,
1 BI,ITAG,X2,Y2,Z2,LD)
C SUBROUTINE HELIX GENERATES SEGMENT GEOMETRY DATA FOR A HELIX OF NS
C SEGMENTS
INTEGER*4 ITAG,N1,N2,N,NP,M1,M2,M,MP,IPSYM
REAL*8 PI,S,HL,A1,B1,A2,B2
COMMON/DATAD/N1,N2,N,NP,M1,M2,M,MP,IPSYM,WLAM
DIMENSION X2(LD),Y2(LD),Z2(LD),ITAG(LD)
DIMENSION X(LD),Y(LD),Z(LD),BI(LD)
DATA PI/3.141592654D0/
IST=N+1
N=N+NS
NP=N
MP=M
IPSYM=0
IF(NS.LT.1) RETURN
TURNS=ABS(HL/S)
ZINC=ABS(HL/NS)
Z(IST)=0.
DO 25 I=IST,N
BI(I)=RAD
ITAG(I)=ITG
IF(I.NE.IST) Z(I)=Z(I-1)+ZINC
Z2(I)=Z(I)+ZINC
IF(A2.NE.A1) GO TO 10
IF(B1.EQ.0) B1=A1
X(I)=A1*DCOS(2.*PI*Z(I)/S)
Y(I)=B1*DSIN(2.*PI*Z(I)/S)
X2(I)=A1*DCOS(2.*PI*Z2(I)/S)
Y2(I)=B1*DSIN(2.*PI*Z2(I)/S)
GO TO 20
10 IF(B2.EQ.0) B2=A2
X(I)=(A1+(A2-A1)*Z(I)/ABS(HL))*DCOS(2.*PI*Z(I)/S)
Y(I)=(B1+(B2-B1)*Z(I)/ABS(HL))*DSIN(2.*PI*Z(I)/S)
X2(I)=(A1+(A2-A1)*Z2(I)/ABS(HL))*DCOS(2.*PI*Z2(I)/S)
Y2(I)=(B1+(B2-B1)*Z2(I)/ABS(HL))*DSIN(2.*PI*Z2(I)/S)
20 IF(HL.GT.0) GO TO 25
COPY=X(I)
X(I)=Y(I)
Y(I)=COPY
COPY=X2(I)
X2(I)=Y2(I)
Y2(I)=COPY
25 CONTINUE
IF(A2.EQ.A1) GO TO 21
SANGLE=DATAN(A2/(ABS(HL)+(ABS(HL)*A1)/(A2-A1)))
WRITE(IW,104) SANGLE
104 FORMAT(5X,'THE CONE ANGLE OF THE SPIRAL IS',F10.4)
RETURN
21 IF(A1.NE.B1) GO TO 30
HDIA=2.*A1
TURN=HDIA*PI
PITCH=DATAN(S/(PI*HDIA))
C TURN=TURN/DCOS(PITCH)
TURN=TURN/COS(PITCH)
PITCH=180.*PITCH/PI
GO TO 40
30 IF(A1.LT.B1) GO TO 34
HMAJ=2.*A1
HMIN=2.*B1
GO TO 35
34 HMAJ=2.*B1
HMIN=2.*A1
C 35 HDIA=DSQRT((HMAJ**2+HMIN**2)/2*HMAJ)
35 HDIA=SQRT((HMAJ**2+HMIN**2)/2*HMAJ)
TURN=2.*PI*HDIA
PITCH=(180./PI)*DATAN(S/(PI*HDIA))
40 WRITE(IW,105) PITCH,TURN
105 FORMAT(5X,'THE PITCH ANGLE IS',F10.4/5X,'THE LENGTH OF WIRE/TURN I
1S',F10.4)
RETURN
END
SUBROUTINE GFIL(CM,ZARRAY,X,Y,Z,SI,BI,ALP,BET,SALP,
1 ICON1,ICON2,ITAG,IP,IW,IGFL,IPRT,LD,LD2,IRESRV)
C
C GFIL READS THE N.G.F. FILE
C
CLARGE: CM
COMPLEX CM
COMPLEX*16 ZARRAY,SSX
COMPLEX*16 ZRATI,ZRATI2,T1,FRATI
C**
REAL*4 DXA,DYA,XSA,YSA
COMPLEX*8 AR1,AR2,AR3,EPSCF
C**
INTEGER*4 ICON1,ICON2,ITAG,IOUT,I,J,K,N,N1,N2,IOP,
1 NP,M1,M2,M,MP,IPSYM,NEQ,NPEQ,NOP,IDM1
INTEGER*4 IMAT,NPBLK,NLAST,NLSYM,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL
COMMON/DATAD/N1,N2,N,NP,M1,M2,M,MP,IPSYM,WLAM
COMMON/GND/ZRATI,ZRATI2,FRATI,CL,CH,SCRWL,SCRWR,NRADL,KSYMP,
1IFAR,IPERF,T1,T2
COMMON/GGRID/AR1(11,10,4),AR2(17,5,4),AR3(9,8,4),EPSCF,DXA(3),
1 DYA(3),XSA(3),YSA(3),NXA(3),NYA(3)
COMMON/MATPAR/ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT,
1 ICASX,NBBX,NPBX,NLBX,NBBL,NPBL,NLBL
COMMON/SMAT/ SSX(16,16)
COMMON/ZLOAD/ NLOAD,NLODF
COMMON/SAVE/ KCOM,COM(19,5),EPSR,SIG,SCRWLT,SCRWRT,FMHZ
DIMENSION CM(IRESRV),ZARRAY(LD),IP(LD2),ICON1(LD),ICON2(LD),
1 ITAG(LD)
DIMENSION X(LD),Y(LD),Z(LD),SI(LD),BI(LD),ALP(LD),BET(LD),
1 SALP(LD)
C**
C** DATA IGFL/20/
C**
C $NODEBUG
C**
C D WRITE(*,*) ' GFIL: START, IGFL=',IGFL
C**
C** GREEN'S FUNCTION FILE NAME WILL BE REQUESTED HERE IF IGFL
C** HAS NOT YET BEEN CONNECTED TO 'TAPE.[IGFL]' BY GFOUT
C**
WRITE(*,'(A,I2,A)') ' OPEN UNIT ',IGFL,' FOR N.G.F. INPUT FILE'
READ (IGFL) N1,NP,M1,MP,WLAM,FMHZ,IPSYM,KSYMP,IPERF,NRADL,EPSR,
1 SIG,SCRWLT,SCRWRT,NLODF,KCOM
C**
$DEBUG
C**
N=N1
M=M1
N2=N1+1
M2=M1+1
IDM1=1
IF (N1.EQ.0) GO TO 2
C READ SEG. DATA AND CONVERT BACK TO END COORD. IN UNITS OF METERS
READ (IGFL) (X(I),I=1,N1),(Y(I),I=1,N1),(Z(I),I=1,N1)
READ (IGFL) (SI(I),I=1,N1),(BI(I),I=1,N1),(ALP(I),I=1,N1)
READ (IGFL) (BET(I),I=1,N1),(SALP(I),I=1,N1)
READ (IGFL) (ICON1(I),I=1,N1),(ICON2(I),I=1,N1)
READ (IGFL) (ITAG(I),I=1,N1)
IF (NLODF.NE.0) READ (IGFL) (ZARRAY(I),I=1,N1)
DO 1 I=1,N1
XI=X(I)*WLAM
YI=Y(I)*WLAM
ZI=Z(I)*WLAM
DX=SI(I)*.5*WLAM
X(I)=XI-ALP(I)*DX
Y(I)=YI-BET(I)*DX
Z(I)=ZI-SALP(I)*DX
SI(I)=XI+ALP(I)*DX
ALP(I)=YI+BET(I)*DX
BET(I)=ZI+SALP(I)*DX
BI(I)=BI(I)*WLAM
1 CONTINUE
2 IF (M1.EQ.0) GO TO 4
J=LD-M1+1
C READ PATCH DATA AND CONVERT TO METERS
READ (IGFL) (X(I),I=J,LD),(Y(I),I=J,LD),(Z(I),I=J,LD)
READ (IGFL) (SI(I),I=J,LD),(BI(I),I=J,LD),(ALP(I),I=J,LD)
READ (IGFL) (BET(I),I=J,LD),(SALP(I),I=J,LD)
READ (IGFL) (ICON1(I),I=J,LD),(ICON2(I),I=J,LD)
READ (IGFL) (ITAG(I),I=J,LD)
DX=WLAM*WLAM
DO 3 I=J,LD
X(I)=X(I)*WLAM
Y(I)=Y(I)*WLAM
Z(I)=Z(I)*WLAM
3 BI(I)=BI(I)*DX
4 READ (IGFL) ICASE,NBLOKS,NPBLK,NLAST,NBLSYM,NPSYM,NLSYM,IMAT
IF (IPERF.EQ.2) READ (IGFL) AR1,AR2,AR3,EPSCF,DXA,DYA,XSA,YSA,
1 NXA,NYA
NEQ=N1+2*M1
NPEQ=NP+2*MP
NOP=NEQ/NPEQ
IF (NOP.GT.1) READ (IGFL) ((SSX(I,J),I=1,NOP),J=1,NOP)
READ (IGFL) (IP(I),I=1,NEQ),COM
C READ MATRIX A AND WRITE TAPE13 FOR OUT OF CORE
IF (ICASE.GT.2) GO TO 5
IOUT=NEQ*NPEQ
READ (IGFL) (CM(I),I=1,IOUT)
GO TO 10
5 REWIND 13
IF (ICASE.NE.4) GO TO 7
IOUT=NPEQ*NPEQ
DO 6 K=1,NOP
READ (IGFL) (CM(J),J=1,IOUT)
6 WRITE (13) (CM(J),J=1,IOUT)
GO TO 9
7 IOUT=NPSYM*NPEQ*2
NBL2=2*NBLSYM
DO 8 IOP=1,NOP
DO 8 I=1,NBL2
CALL BLCKIN (CM,IDM1,IOUT,1,206,IGFL)
8 CALL BLCKOT (CM,IDM1,IOUT,1,205,13)
9 REWIND 13
10 REWIND IGFL
C WRITE(IW,N) G.F. HEADING
WRITE(IW,16)
WRITE(IW,14)
WRITE(IW,14)
WRITE(IW,17)
WRITE(IW,18) N1,M1
IF (NOP.GT.1) WRITE(IW,19) NOP
WRITE(IW,20) IMAT,ICASE
IF (ICASE.LT.3) GO TO 11
NBL2=NEQ*NPEQ
WRITE(IW,21) NBL2
11 WRITE(IW,22) FMHZ
IF (KSYMP.EQ.2.AND.IPERF.EQ.1) WRITE(IW,23)
IF (KSYMP.EQ.2.AND.IPERF.EQ.0) WRITE(IW,27)
IF (KSYMP.EQ.2.AND.IPERF.EQ.2) WRITE(IW,28)
IF (KSYMP.EQ.2.AND.IPERF.NE.1) WRITE(IW,24) EPSR,SIG
WRITE(IW,17)
DO 12 J=1,KCOM
12 WRITE(IW,15) (COM(I,J),I=1,19)
WRITE(IW,17)
WRITE(IW,14)
WRITE(IW,14)
WRITE(IW,16)
IF (IPRT.EQ.0) GOTO 100
WRITE(IW,25)
DO 13 I=1,N1
13 WRITE(IW,26) I,X(I),Y(I),Z(I),SI(I),ALP(I),BET(I)
100 CONTINUE
C**
CLOSE(IGFL)
C**
C D WRITE(*,*) ' GFIL: CLOSE N.G.F. INPUT FILE AND RETURN'
C**
RETURN
C
14 FORMAT (5X,50H**************************************************,3
14H**********************************)
15 FORMAT (5X,3H** ,19A4,5H **)
16 FORMAT (////)
17 FORMAT (5X,2H**,80X,2H**)
18 FORMAT (5X,29H** NUMERICAL GREEN'S FUNCTION,53X,2H**,/,5X,17H** NO
1. SEGMENTS =,I4,10X,13HNO. PATCHES =,I4,34X,2H**)
19 FORMAT (5X,27H** NO. SYMMETRIC SECTIONS =,I4,51X,2H**)
20 FORMAT (5X,34H** N.G.F. MATRIX - CORE STORAGE =,I7,23H COMPLEX NU
1MBERS, CASE,I2,16X,2H**)
21 FORMAT (5X,2H**,19X,13HMATRIX SIZE =,I7,16H COMPLEX NUMBERS,25X,2H
1**)
22 FORMAT (5X,14H** FREQUENCY =,1P,E12.5,5H MHZ.,51X,2H**)
23 FORMAT (5X,17H** PERFECT GROUND,65X,2H**)
24 FORMAT (5X,44H** GROUND PARAMETERS - DIELECTRIC CONSTANT =,1P,
1E12.5,26X,2H**,/,5X,2H**,21X,14HCONDUCTIVITY =,E12.5,8H MHOS/M.,
225X,2H**)
25 FORMAT (39X,31HNUMERICAL GREEN'S FUNCTION DATA,/,41X,27HCOORDINATE
1S OF SEGMENT ENDS,/,51X,8H(METERS),/,5X,4HSEG.,11X,19H- - - END ON
2E - - -,26X,19H- - - END TWO - - -,/,6X,3HNO.,6X,1HX,14X,1HY,14X,1
3HZ,14X,1HX,14X,1HY,14X,1HZ)
26 FORMAT (1X,I7,1P,6E15.6)
27 FORMAT (5X,55H** FINITE GROUND. REFLECTION COEFFICIENT APPROXIMAT
1ION,27X,2H**)
28 FORMAT (5X,38H** FINITE GROUND. SOMMERFELD SOLUTION,44X,2H**)
END